COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.SBTTL Large block allocator
C00006 00003	 Routine to release free storage.  R0=LOC[LTAG[BLOCK]] + 1.
C00009 00004	.SBTTL Small block allocator
C00012 00005	Routine to allocate an item of size R0 words.  Returns location
C00017 ENDMK
C⊗;
.SBTTL Large block allocator

; Assembly variables
FREL = 4000		;Test of small amount.  Maximum = 40000 (IN WORDS!)

; Free storage block
.EVEN
FREEPT:	FREEST
	-1		;Left bdry tag is negative.
FREEST:	FREL*2		;Beginning of free storage.  Boundary tag.
	.BLKW	FREL-2	;
FREEND:	FREL*2		;End of free storage.  Boundary tag.
	-1		;Right bdry tag is negative.

; Routine to assign storage.  Amount of words requested in R0.
;	Location of first word in block (not the boundary tag) returned
;	in R0.
;  The boundary tag method described in Knuth I.2.5 is
;	used.  Each block of storage has a boundary tag at
;	each end, with identical contents:  The number
;	of bytes in the whole area if available, and the opposite
;	of that if busy.  Artificial busy areas above and below
;	free storage.
GTFREE:	MOV R2,-(SP)	;Save R2 on stack.
	ASL R0		;Convert words to bytes
	BLT FREERR	;Asked for negative number of words.
	ADD #4, R0	;Need 2 extra words for boundary tags
	MOV FREEPT, R1	;R1 ← running LOC[LTAG[*]]
FRTRY:	CMP R1,#FREEND	;Are we off the end of free storage?
	BLOS FR2	;No.
	MOV #FREEST,R1	;Yes.  Reset pointer to beginning.
FR2:	CMP (R1),R0	;Do we have enough room here?
	BGE FFOUND	;Yes
	TST (R1)	;No.  Is this area busy?  If so, its count is negative.
	BGE FRPOS	;No.
	SUB (R1),R1	;Yes.  R1 ← LOC[LTAG[next] by subtraction.
	BR  FR1
FRPOS:	ADD (R1),R1	;R1 ← LOC[LTAG[next] by addition.
FR1:	CMP R1,FREEPT	;Have we cycled all through free storage
	BEQ FROVFL	;Yes.  No room!
	BR  FRTRY	;No.  Try again.
FFOUND:	BEQ FEXACT	;If 0, then exact fit.
	MOV R1,R2	;Divide the found block into FOUND and HOLE.
			;Thus, R1 = LOC[LTAG[FOUND]].
	ADD R0,R2	;R2 ← LOC[LTAG[HOLE]]
	NEG R0		;R0 ← negative (busy) count of FOUND.
	MOV R0,-2(R2)	;RTAG[FOUND] ← new FOUND count.
	MOV R0,-(SP)	;Save R0.
	ADD (R1),R0	;R0 ← new HOLE count.
	MOV R0,(R2)	;LTAG[HOLE] ← new HOLE count.
	MOV R2,FREEPT	;Free pointer ← LOC[LTAG[HOLE]]
	MOV R1,R2	;
	TST -(R2)	;
	ADD (R1),R2	;R2 ← LOC[RTAG[HOLE]].
	MOV R0,(R2)	;RTAG[HOLE] ← new HOLE count.
	MOV (SP)+,(R1)+	;LTAG[FOUND] ← new FOUND count.
FRRET:	MOV R1,R0	;R0 (result) ← LOC[LTAG[FOUND]] + 1.
	MOV (SP)+,R2	;Restore R2
	RTS PC		;Done.
FEXACT:	MOV R1,R2	;
	ADD (R1),R2	;R2 ← LOC[RTAG[FOUND]]
	NEG (R1)+	;LTAG[FOUND] ← new (busy) count.
	NEG -(R2)	;RTAG[FOUND] ← new (busy) count.
	BR FRRET	;Ready to return
FREERR:	HALERR FRMS1
FROVFL:	HALERR FRMS2
FRMS1:	ASCIE </YOU ASKED FOR NEGATIVE AMOUNT OF FREE SPACE/>
FRMS2:	ASCIE /FREE STORAGE EXHAUSTED/


; Routine to release free storage.  R0=LOC[LTAG[BLOCK]] + 1.
; Call the currently released block BLOCK, the adjacent one
;	below LOW, and the adjacent one above HIGH.
RLFREE:	MOV -(R0),R1	;R1 ← LOC[LTAG[BLOCK]]
	BGE RLFER2	;Can't release available space.
	MOV R0,R1	;R1 ← LOC[LTAG[BLOCK]]
	SUB (R0),R0	;R0 ← LOC[LTAG[HIGH]]
	CMP (R1),-2(R0)	;Do the two bdry tags agree?
	BNE RLFER1	;No.  Storage munged!!
	NEG (R1)	;Count is now positive in LTAG[BLOCK].
	TST -2(R1)	;Is LOW available?
	BLT MERGR	;No.  Cannot merge left.
	ADD -2(R1),(R1)	;Yes.  LTAG[BLOCK] ← New count
	MOV (R1),-2(R0)	;RTAG[BLOCK] ← New count
	MOV R0,R1	;
	SUB -2(R1),R1	;R1 ← LOC[LTAG[LOW]]
	MOV -2(R0),(R1)	;LTAG[LOW] ← New count
			;At this point, call LOW&BLOCK = BLOCK.
MERGR:	TST (R0)	;Is HIGH available?
	BLT RLRET	;No.  Prepare to return.
	ADD (R0),(R1)	;LTAG[BLOCK] ← New count
	CMP FREEPT,R0	;Will FREEPT point into a vacuum?
	BNE RL1		;No.
	MOV R1,FREEPT	;Yes.  Reset FREEPT ← LOC[LTAG[BLOCK]]
RL1:	ADD (R0),R0	;R0 ← LOC[RTAG[HIGH]] + 1
			;At this point, call BLOCK&HIGH = BLOCK.
RLRET:	MOV (R1),-2(R0)	;RTAG[BLOCK] ← New count
	RTS PC		;Done.
RLFER1:	HALERR RLMS1
RLFER2:	HALERR RLMS2
RLMS1:	.ASCIZ /RLFREE FEARS FREE STORAGE IS WIPED OUT/
RLMS2:	ASCIE /ATTEMPT TO FREE ALREADY AVAILABLE SPACE/
.SBTTL Small block allocator
;Coded by RF, 10-Sept-1974

;For small items like value cells, typically ranging in size
;from 1 to 20 words, many of which are needed, there is a 
;small block allocator.  Sixteen items of like size are
;allocated simultaneously with GTFREE when needed.  SZHH points
;to a the size header for the smallest size currently being
;used.  (One efficiency not currently programmed in is
;to have this initially point to a size header for an impossible
;large size item.)  Each size has its own header, pointing
;down a list of small blocks which have been allocated for this
;size.  Each block holds the 16 items.

;Global, pointing to smallest size header.
SZHH:	.BLKW 1		;Size header Header.

;Size header.  Each small block size has one of these.
	II == 0
	XX  NXTSH	;Next size header, for bigger blocks. (Must be first field)
	XX  SIZE	;Size of item in small block in WORDS.
	XX  NALLOC	;Number of allocated blocks.
	XX  BLKLST	;Points to first small block of this size.
	SIZSH = II/2	;How long a size header is in WORDS.

;Small block.  Each one holds 16 items, as well as this info:
	II == 0
	XX  NEXTB	;Next block of this size. (Must be first field)
	XX  MASK	;Each bit for one item.  0=free; 1=busy.
	XX  FRBIT	;Rotating bit.  Points to last assigned place.
	XX  WORD0	;First word of 16*SIZE words.
	SIZBLH = II/2	;How long a block header is in WORDS.

;Routine to allocate an item of size R0 words.  Returns location
;	of item found in R0.
GTITEM:	MOV R2,-(SP)	;Save R2.
	MOV R3,-(SP)	;Save R3.
	MOV #SZHH,R3	;R3 ← LOC[SZHH].  Used to link in new.
	MOV NXTSH(r3),R1	;R1 ← LOC[first size header]
	BEQ GTNWSH	;If 0, then need new size header.
GT1:	MOV SIZE(R1),R2	;R2 ← size of current size header in words.
	CMP R2,R0	;Is this the size we want?
	BEQ GTSZFD	;Yes.  We found the size.
	BGT GTNWSH	;No, too large.  Need new size header.
	MOV R1,R3	;No, too small. R3 ← LOC[too small size header]
	MOV NXTSH(R1),R1 ;R1 ← LOC[next size header]
	BNE GT1		;If there is one, try again.
GTNWSH:	MOV R0,-(SP)	;Save R0.
	MOV R1,-(SP)	;Save R1.
	MOV #SIZSH,R0	;R0 ← Number of words needed for a size header.
	JSR PC,GTFREE	;Get a block of that size.
	MOV R0,R1	;R1 ← LOC[new size header]
	MOV (SP)+,NXTSH(R1) ;NXTSH[new size header] ← LOC[next size header]
	MOV R1,NXTSH(R3);NXTSH[previous size header] ← LOC[new size header]
	MOV (SP)+,R0	;Restore R0 ← size desired in words.
	MOV R0,SIZE(R1)	;SIZE[new size header] ← correct size
	CLR NALLOC(R1)	;NALLOC[new size header] ← 0
	CLR BLKLST(R1)	;BLKLST[new size header] ← 0
;At this point, we have found a size header of the right size.
;R0 = size, R1 = LOC[size header found]
GTSZFD:	ROL R0		;R0 ← desired size in BYTES.
	MOV BLKLST(R1),R3;R3 ← LOC[block to try]
	BEQ GTNWBL	;If no more blocks, then get a new one.
GT5:	CMP #-1,MASK(R3);Is this block full?
	BNE GDBLK	;No.  Can use it.
	MOV NEXTB(R3),R3;Yes.  Get another block.
	BNE GT5		;If there is one, try it.
GTNWBL:	ROL R0		;Else need new block.
	ROL R0		;Recall:  R0 = 2*SIZE (since in bytes)
	ROL R0		;R0 ← 20*SIZE words
	ADD #SIZBLH,R0	;R0 ← Size of block we need.
	MOV R1,R2	;R1 will be clobbered soon.  R2 ← LOC[size header].
	JSR PC,GTFREE	;R0 ← LOC[new block]
	MOV BLKLST(R2),NEXTB(R0);NEXTB[block just made] ← LOC[first old block]
	MOV R0,BLKLST(R2);BLKLST[size header] ← LOC[block just made]
	INC NALLOC(R2)	;Just allocated a new block.
	MOV #100000,FRBIT(R0);Set its FRBIT arbitrarily.
	MOV FRBIT(R0),MASK(R0);We will assign this item to caller.
	ADD #WORD0,R0	;R0 ← LOC[new item]
	BR  GTRET	;Prepare to return.
GDBLK:	ROR FRBIT(R3)	;Set FRBIT to next item.
	BIT FRBIT(R3),MASK(R3) ;Is this item available?
	BNE GDBLK		;No.  Try again.
	BIS FRBIT(R3),MASK(R3) ;Yes.  Set mask appropriately.
	MOV R3,R2	;
	ADD #WORD0,R2	;R2 ← LOC[first item in block]
	MOV FRBIT(R3),R3;R3 ← FRBIT.  We are about to calculate address of item.
	BMI GT3		;If R3 has 15 bit on, then R2 is right.
GT4:	ADD R0,R2	;Else R2 ← LOC[next item in block]
	ROL R3		;
	BPL GT4		;Try again.
GT3:	MOV R2,R0	;Almost done.  R0 ← LOC[found item]
GTRET:	MOV (SP)+,R3	;Restore R3
	MOV (SP)+,R2	;Restore R2
	RTS PC		;Done.